home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / error.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-06-02  |  2.8 KB  |  97 lines
  1. /*
  2.  *
  3.  * e r r o r . c             -- The error procedure
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *           Author: Erick Gallesio [eg@unice.fr]
  20.  *    Creation date: 14-Nov-1993 14:58
  21.  * Last file update:  2-Jun-1996 21:49
  22.  */
  23.  
  24. #include "stk.h"
  25.  
  26. static jmp_buf global_jmp_buf;         /* Jump buffer denoting toplevel context */
  27. jmp_buf *Top_jmp_buf = &global_jmp_buf;
  28.  
  29. long Error_context = ERR_FATAL;
  30.  
  31.  
  32. void STk_err(char *message, SCM x)
  33. {
  34.   SCM tmp;
  35.   static int err_counter=0; /* to avoid loops when REPORT_ERROR proc is buggy */
  36.   char head[MAX_PATH_LENGTH+50];
  37.  
  38.   err_counter += 1;
  39.  
  40.   STk_reset_eval_hook();
  41.  
  42.   if (!(Error_context & ERR_IGNORED)) {
  43.     /* Error is not ignored: A message must be printed */
  44.     if (*message) {
  45.       switch (Error_context) {
  46.         case ERR_READ_FROM_STRING: 
  47.           strcpy(head,"*** Read from string error:\n"); break;
  48.         case ERR_FATAL:     
  49.     case ERR_OK:
  50.             if (STk_current_filename==UNBOUND)
  51.           sprintf(head, "*** Error:\n");
  52.         else {
  53.           sprintf(head, "*** Error at line %d of file %s:\n",
  54.               STk_line_counter, CHARS(STk_current_filename));
  55.           STk_current_filename = UNBOUND;
  56.         }
  57.         break;
  58. #ifdef USE_TK
  59.     case ERR_TCL_BACKGROUND:    
  60.           strcpy(head, "*** Background error:\n"); break;
  61. #endif
  62.       }
  63.  
  64.       tmp = VCELL(Intern(REPORT_ERROR));
  65.       if (tmp!=UNBOUND && STk_procedurep(tmp)==Truth &&  err_counter==1 && *message)
  66.     Apply(tmp, LIST3(STk_makestring(head), 
  67.              STk_makestring(message), 
  68.              STk_uncode(x)));
  69.       else {
  70.     if (err_counter>1) 
  71.       fprintf(STk_stderr, "WARNING: %s is buggy!!\n", REPORT_ERROR);
  72.     fprintf(STk_stderr, "\n%s    %s", head, message);
  73.     if (NNULLP(x)) {
  74.       fprintf(STk_stderr, ": "); 
  75.       STk_print(STk_uncode(x), STk_curr_eport, WRT_MODE);
  76.     }
  77.     STk_show_eval_stack(5);
  78.       }
  79.     }
  80.     fflush(STk_stdout); fflush(STk_stderr);
  81.     STk_reset_eval_stack();
  82.     /* 
  83.      * Do all the terminal thunk of dynamic winds and make a long jump to
  84.      * location retained in Top_jmp_buf 
  85.      */
  86.     STk_unwind_all();
  87.   }
  88.  
  89.   err_counter = 0;
  90.   switch (Error_context) {
  91.     case ERR_FATAL: 
  92.       STk_panic("FATAL ERROR IN CRITICAL CODE SECTION. ABANDON\n");
  93.     default:
  94.       longjmp(*Top_jmp_buf, JMP_ERROR);
  95.   }
  96. }
  97.